home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Fritz: All Fritz
/
All Fritz.zip
/
All Fritz
/
FILES
/
PROGASIC
/
BASFILES.LZH
/
QBTXKILL.BAS
< prev
next >
Wrap
BASIC Source File
|
1988-09-10
|
13KB
|
237 lines
'$INCLUDE:'QBTOOLS.INC'
'' '$INCLUDE: 'qbtools2.inc'
'' '$INCLUDE: 'qbt2indx.inc'
'' '-------------------------Standard Include Merge Section-------------------
DEFSNG A-Z
SUB IndexKill (IxNum%, Ky$, Mrec%, Xnm$(), Xk$(), Xh%(), sc%) STATIC
IF Mrec% < 1 THEN
GOTO badkey
END IF
IF sc% < 1 THEN
GOTO badkey
END IF
GET #IxNum%, sc% ' key to delete
dk$ = Xk$(IxNum%, 1) ' key
ds% = sc% ' position in file
dl% = CVI(Xk$(IxNum%, 2)) ' left pointer
dr% = CVI(Xk$(IxNum%, 3)) ' right pointer
dp% = CVI(Xk$(IxNum%, 4)) ' parent pointer
dm% = CVI(Xk$(IxNum%, 5)) ' pointer to ACTUAL record
dd% = CVI(Xk$(IxNum%, 6)) ' pointer to next deleted
IF (dp% <> 0) THEN ' there IS a parent
REM $subtitle:'There is a parent and a left child'
REM $page
IF (dl% <> 0) AND (dr% = 0) THEN ' left ONLY
GET #IxNum%, dp% ' get the parent
IF CVI(Xk$(IxNum%, 2)) = ds% THEN ' yes, link to the left
side% = 2
ELSE
side% = 3 ' otherwise, right
END IF
LSET Xk$(IxNum%, side%) = MKI$(dl%) ' change the link
PUT #IxNum%, dp% ' write it back
GET #IxNum%, dl% ' get the kid
LSET Xk$(IxNum%, 4) = MKI$(dp%) ' relink the child
PUT #IxNum%, dl% ' write it back
GOSUB initkeyrec ' init the record
LSET Xk$(IxNum%, 6) = MKI$(Xh%(IxNum%, 4)) ' allocate on stack
PUT #IxNum%, ds% ' write it away
Xh%(IxNum%, 4) = ds% ' new deleted lifo rec
END IF
REM $subtitle:'There is a parent and a right child'
REM $page
IF (dr% <> 0) AND (dl% = 0) THEN ' right ONLY
GET #IxNum%, dp% ' get the parent
IF CVI(Xk$(IxNum%, 2)) = ds% THEN ' yes, link to the left
side% = 2
ELSE
side% = 3 ' otherwise, right
END IF
LSET Xk$(IxNum%, side%) = MKI$(dr%) ' change the link
PUT #IxNum%, dp% ' write it back
GET #IxNum%, dr% ' get the kid
LSET Xk$(IxNum%, 4) = MKI$(dp%) ' relink the child
PUT #IxNum%, dr% ' write it back
GOSUB initkeyrec ' init the record
LSET Xk$(IxNum%, 6) = MKI$(Xh%(IxNum%, 4)) ' allocate on stack
PUT #IxNum%, ds% ' write it away
Xh%(IxNum%, 4) = ds% ' new deleted lifo rec
END IF
REM $subtitle:'There is a parent , but no children'
REM $page
IF ((dl% = 0) AND (dr% = 0)) THEN ' NO children
GET #IxNum%, dp% ' get the parent
IF CVI(Xk$(IxNum%, 2)) = ds% THEN ' yes, link to the left
side% = 2
ELSE
side% = 3 ' otherwise, right
END IF
LSET Xk$(IxNum%, side%) = MKI$(0) ' change the link
PUT #IxNum%, dp% ' write it back
GOSUB initkeyrec ' init the record
LSET Xk$(IxNum%, 6) = MKI$(Xh%(IxNum%, 4)) ' allocate on stack
PUT #IxNum%, ds% ' write it away
Xh%(IxNum%, 4) = ds% ' new deleted lifo rec
END IF
REM $subtitle:'There is a parent and both left & right children'
REM $page
IF (dl% <> 0) AND (dr% <> 0) THEN ' Yup, two kids
GET #IxNum%, dl% ' get the left
LSET Xk$(IxNum%, 4) = MKI$(dp%) ' give a new parent
PUT #IxNum%, dl% ' write it back
pnh% = dl% ' last key so far
nh% = CVI(Xk$(IxNum%, 3)) ' right key
WHILE nh% <> 0 ' keep getting
GET #IxNum%, nh% ' get right
pnh% = nh% ' last key so far
nh% = CVI(Xk$(IxNum%, 3)) ' right key
WEND
LSET Xk$(IxNum%, 3) = MKI$(dr%) ' link deleted's right to this
PUT #IxNum%, pnh% ' write this one back
GET #IxNum%, dr% ' get the right one
LSET Xk$(IxNum%, 4) = MKI$(pnh%) ' set the new parent
PUT #IxNum%, dr% ' write it back
GET #IxNum%, dp% ' fetch the parent
IF CVI(Xk$(IxNum%, 2)) = ds% THEN ' yes, link to the left
side% = 2
ELSE
side% = 3 ' otherwise, right
END IF
LSET Xk$(IxNum%, side%) = MKI$(dl%) ' change the link
PUT #IxNum%, dp% ' write it back
GOSUB initkeyrec ' init the record
LSET Xk$(IxNum%, 6) = MKI$(Xh%(IxNum%, 4)) ' allocate on stack
PUT #IxNum%, ds% ' write it away
Xh%(IxNum%, 4) = ds% ' new deleted lifo rec
END IF
ELSEIF (ds% = 1) THEN ' NO PARENT
REM $subtitle:'No parent, and there is a left child'
REM $page
IF (dl% <> 0) AND (dr% = 0) THEN ' left ONLY
GET #IxNum%, dl% ' get left
lrec% = CVI(Xk$(IxNum%, 2)) ' the left grandchild
rrec% = CVI(Xk$(IxNum%, 3)) ' the right grandchild
LSET Xk$(IxNum%, 4) = MKI$(0) ' no parent for this
PUT #IxNum%, 1 ' write to 1
IF (lrec% <> 0) THEN ' yes, theres a left gc
GET #IxNum%, lrec% ' get the left grandchild
LSET Xk$(IxNum%, 4) = MKI$(1) ' new parent
PUT #IxNum%, lrec% ' put this record away
END IF
IF (rrec% <> 0) THEN ' yes, theres a right gc
GET #IxNum%, rrec% ' get the right grandchild
LSET Xk$(IxNum%, 4) = MKI$(1) ' new parent
PUT #IxNum%, rrec% ' put this record away
END IF
GOSUB initkeyrec ' init the record
LSET Xk$(IxNum%, 6) = MKI$(Xh%(IxNum%, 4)) ' allocate on stack
PUT #IxNum%, dl% ' write it away
Xh%(IxNum%, 4) = dl% ' new deleted lifo rec
END IF
REM $subtitle:'No parent, and there is a right child'
REM $page
IF (dr% <> 0) AND (dl% = 0) THEN ' right ONLY
GET #IxNum%, dr% ' get right
lrec% = CVI(Xk$(IxNum%, 2)) ' the left grandchild
rrec% = CVI(Xk$(IxNum%, 3)) ' the right grandchild
LSET Xk$(IxNum%, 4) = MKI$(0) ' no parent for this
PUT #IxNum%, 1 ' write to 1
IF (lrec% <> 0) THEN ' yes, theres a left gc
GET #IxNum%, lrec% ' get the left grandchild
LSET Xk$(IxNum%, 4) = MKI$(1) ' new parent
PUT #IxNum%, lrec% ' put this record away
END IF
IF (rrec% <> 0) THEN ' yes, theres a right gc
GET #IxNum%, rrec% ' get the right grandchild
LSET Xk$(IxNum%, 4) = MKI$(1) ' new parent
PUT #IxNum%, rrec% ' put this record away
END IF
GOSUB initkeyrec ' init the record
LSET Xk$(IxNum%, 6) = MKI$(Xh%(IxNum%, 4)) ' allocate on stack
PUT #IxNum%, dr% ' write it away
Xh%(IxNum%, 4) = dr% ' new deleted lifo rec
END IF
REM $subtitle:'No parent and no children'
REM $page
IF ((dl% = 0) AND (dr% = 0)) THEN ' NO children, NO parents, lonely!
' Just in case index is large ...
CLOSE #IxNum% ' close the index
hn$ = Xnm$(IxNum%) ' Name of the index
kl% = Xh%(IxNum%, 1) ' Key Length
CALL IndexCreate(IxNum%, hn$, kl%) ' Re-create the file
IF aesbfatal% THEN ' Fatal error opening index
CALL IndexError("BITKIL/BITCRE(RE)")
END IF
CALL IndexOpen(IxNum%, hn$, Xnm$(), Xk$(), Xh%()) ' Ya got it, just create it again
END IF
REM $subtitle:'No parent, but both left and right children'
REM $page
IF (dl% <> 0) AND (dr% <> 0) THEN ' Yup, two kids
GET #IxNum%, dl% ' get the left
lrec% = CVI(Xk$(IxNum%, 2)) ' the left grandchild
rrec% = CVI(Xk$(IxNum%, 3)) ' the right grandchild
LSET Xk$(IxNum%, 4) = MKI$(0) ' no parent for this
PUT #IxNum%, 1 ' write to 1
IF (lrec% <> 0) THEN ' yes, theres a left gc
GET #IxNum%, lrec% ' get the left grandchild
LSET Xk$(IxNum%, 4) = MKI$(1) ' new parent
PUT #IxNum%, lrec% ' put this record away
END IF
IF (rrec% <> 0) THEN ' yes, theres a right gc
GET #IxNum%, rrec% ' get the right grandchild
LSET Xk$(IxNum%, 4) = MKI$(1) ' new parent
PUT #IxNum%, rrec% ' put this record away
END IF
GET #IxNum%, 1 ' get left again
' thats where the new record is now
pnh% = 1 ' last key so far
nh% = CVI(Xk$(IxNum%, 3)) ' right key
WHILE nh% <> 0 ' keep getting
GET #IxNum%, nh% ' get right
pnh% = nh% ' last key so far
nh% = CVI(Xk$(IxNum%, 3)) ' right key
WEND
LSET Xk$(IxNum%, 3) = MKI$(dr%) ' link deleted's right to this
PUT #IxNum%, pnh% ' write this one back
GET #IxNum%, dr% ' get the right one
LSET Xk$(IxNum%, 4) = MKI$(pnh%) ' set the new parent
PUT #IxNum%, dr% ' write it back
GOSUB initkeyrec ' init the record
LSET Xk$(IxNum%, 6) = MKI$(Xh%(IxNum%, 4)) ' allocate on stack
PUT #IxNum%, dl% ' write it away
Xh%(IxNum%, 4) = dl% ' new deleted lifo rec
END IF
END IF
GOTO goodkey
REM $subtitle:'Initialize a key to blanks'
REM $page
initkeyrec: ' Initialize the key
FOR j% = 2 TO 6
LSET Xk$(IxNum%, j%) = MKI$(0)
NEXT j%
LSET Xk$(IxNum%, 1) = STRING$(Xh%(IxNum%, 1) + 10, 0)
Xh%(IxNum%, 2) = Xh%(IxNum%, 2) - 1
RETURN
goodkey:
sc% = 1
GOTO deleted
badkey:
Mrec% = 0
sc% = 0
deleted:
END SUB